home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / listops.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  8KB  |  364 lines
  1. /* ******************************************************************** */
  2. /* listops.c         Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* further list operations                                        */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: listops.c,v 1.6 1992/03/15 19:47:42 pab Exp $
  9.  *
  10.  * $Log: listops.c,v $
  11.  * Revision 1.6  1992/03/15  19:47:42  pab
  12.  * last_pair fix
  13.  *
  14.  * Revision 1.5  1992/01/07  22:15:36  pab
  15.  * ncc compatable, plus backtrace
  16.  *
  17.  * Revision 1.4  1991/12/22  15:14:15  pab
  18.  * Xmas revision
  19.  *
  20.  * Revision 1.3  1991/09/22  19:14:35  pab
  21.  * Fixed obvious bugs
  22.  *
  23.  * Revision 1.2  1991/09/11  12:07:20  pab
  24.  * 11/9/91 First Alpha release of modified system
  25.  *
  26.  * Revision 1.1  1991/08/12  16:49:43  pab
  27.  * Initial revision
  28.  *
  29.  * Revision 1.4  1991/02/13  18:22:07  kjp
  30.  * Pass.
  31.  *
  32.  */
  33.  
  34. /*
  35.  * Change Log:
  36.  *   Version 1, March 1990 (Compiler rationalisation)
  37.  */
  38.  
  39. #include "defs.h"
  40. #include "structs.h"
  41. #include "funcalls.h"
  42.  
  43. #include "error.h"
  44. #include "global.h"
  45. #include "modboot.h"
  46. #include "symboot.h"
  47. #include "calls.h"
  48. #include "modules.h"
  49. #include "ngenerics.h"
  50.  
  51. LispObject flat_list_copy(LispObject *);
  52.  
  53. EUFUN_1( Fn_null, form)
  54. {
  55.   return (form==nil?lisptrue:nil);
  56. }
  57. EUFUN_CLOSE
  58.  
  59.                 /* Destructive append */
  60. EUFUN_2( Fn_nconc,  form1, form2)
  61. {
  62.   LispObject p = form1;
  63.   if (!is_cons(form1)) return(form2);
  64.   while (CDR(p)!=nil) p = CDR(p);
  65.   CDR(p) = form2;
  66.   return form1;
  67. }
  68. EUFUN_CLOSE
  69.  
  70. EUFUN_2( Fn_append,  l1, l2)
  71. {
  72.   LispObject endptr,walker,val;
  73.  
  74.   if (!is_cons(l1)) return(l2);
  75.  
  76.   /* reasonable append */
  77.   
  78.   val = EUCALL_2(Fn_cons,CAR(l1),nil);
  79.   STACK_TMP(val);
  80.   endptr = val;
  81.   walker = CDR(ARG_0(stackbase)/*l1*/);
  82.   while (is_cons(walker))
  83.     {
  84.       LispObject xx;
  85.       STACK_TMP(endptr);
  86.       STACK_TMP(CDR(walker));
  87.       xx = EUCALL_2(Fn_cons, CAR(walker), nil);
  88.       UNSTACK_TMP(walker);
  89.       UNSTACK_TMP(endptr);
  90.       CDR(endptr)=xx;
  91.       endptr=CDR(endptr);
  92.     }
  93.   CDR(endptr) = ARG_1(stackbase)/*l2*/;
  94.   UNSTACK_TMP(val);
  95.   return(val);
  96. }
  97. EUFUN_CLOSE
  98.  
  99.                 /* Simple predicate for NULL */
  100. EUFUN_1( Fn_lastpair, form)
  101. {
  102.   while (!is_cons(form))
  103.     form = CallError(stacktop,"Not a list in last-pair",form,CONTINUABLE);
  104.   while (is_cons(form) && CDR(form)!=nil)
  105.     form = CDR(form);
  106.   return form;
  107. }
  108. EUFUN_CLOSE
  109.  
  110. EUFUN_1( Fn_nreverse, form)
  111. {
  112.   LispObject x=nil;
  113.   while (form!=nil) {
  114.     LispObject y = CDR(form);
  115.     CDR(form) = x;
  116.     x = form;
  117.     form = y;
  118.   }
  119.   return x;
  120. }
  121. EUFUN_CLOSE
  122.  
  123. EUFUN_3( Fn_assoc, obj, list, fn)
  124. {
  125.   while (list!=nil) {
  126.     LispObject xx;
  127.     EUCALLSET_3(xx,apply2,ARG_2(stackbase),ARG_0(stackbase),CAR(CAR(list)));
  128.     if (xx != nil)  {
  129.       list=ARG_1(stackbase);
  130.       return CAR(list);
  131.     }
  132.     list = ARG_1(stackbase);
  133.     list = CDR(list);
  134.     ARG_1(stackbase) = list;
  135.   }
  136.   return nil;
  137. }
  138. EUFUN_CLOSE
  139.  
  140. EUFUN_3( Fn_member, obj, list, fn)
  141. {
  142.   while (list!=nil) {
  143.     if (EUCALL_3(apply2,ARG_2(stackbase),ARG_0(stackbase),CAR(list)) != nil) {
  144.       return ARG_1(stackbase);
  145.     }
  146.     list = ARG_1(stackbase);
  147.     list = CDR(list);
  148.     ARG_1(stackbase) = list;
  149.   }
  150.   return nil;
  151. }
  152. EUFUN_CLOSE
  153.  
  154. EUFUN_2( Fn_memq,  obj, list)
  155. {
  156.   if (!is_cons(list) && list != nil)
  157.     CallError(stacktop,"memq: non-lists passed",list,NONCONTINUABLE);
  158.  
  159.   while (is_cons(list)) {
  160.     if (obj == CAR(list))
  161.       return(lisptrue);
  162.     else
  163.       list = CDR(list);
  164.   }
  165.   
  166.   return(nil);
  167. }
  168. EUFUN_CLOSE
  169.  
  170. /* ******************************************************************** */
  171. /*                            Lisp Mappers                              */
  172. /* ******************************************************************** */
  173.  
  174. static LispObject mapcar_apply_args(LispObject *stackbase, LispObject set)
  175. {
  176.   LispObject walker,res,ptr;
  177.   LispObject *stacktop=stackbase+1;
  178.  
  179.   ARG_0(stackbase)=nil;
  180.   res = nil; ptr = nil;
  181.  
  182.   walker = set;
  183.   while (is_cons(walker)) 
  184.     {
  185.       if (!is_cons(CAR(walker))) 
  186.     return(nil);
  187.  
  188.       STACK_TMP(CDR(walker));
  189.       if (ptr == nil)
  190.     {
  191.       EUCALLSET_2(res, Fn_cons,CAR(CAR(walker)),nil);
  192.       ARG_0(stackbase)=res;
  193.       ptr = res;
  194.     }
  195.       else
  196.     {
  197.       LispObject xx;
  198.       STACK_TMP(ptr);
  199.       EUCALLSET_2(xx, Fn_cons, CAR(CAR(walker)),nil);
  200.       UNSTACK_TMP(ptr);
  201.       CDR(ptr) = xx;
  202.       ptr = CDR(ptr);
  203.     }
  204.       UNSTACK_TMP(walker);
  205.     }
  206.   res=ARG_0(stackbase);
  207.   return(res);
  208. }
  209.  
  210. static LispObject mapcar_advance_lists(LispObject set)
  211. { 
  212.   LispObject walker = set;
  213.  
  214.   while (is_cons(walker)) {
  215.     CAR(walker) = CDR(CAR(walker));
  216.     walker = CDR(walker);
  217.   }
  218.   
  219.   return(set);
  220. }
  221.  
  222. EUFUN_3( Fn_mapcar, fn, l1, lists)
  223. {
  224.   LispObject flat_list_copy(LispObject *);
  225.   
  226.   if (!is_cons(l1) && l1 != nil)
  227.     CallError(stacktop,"mapcar: not a list",l1,NONCONTINUABLE);
  228.  
  229.   ARG_3(stackbase)=nil;
  230.   stacktop++;
  231.  
  232.   {
  233.     LispObject set,args;
  234.     LispObject res,ptr,val;
  235.     
  236.     /* More general... */
  237.  
  238.     EUCALLSET_1(set, flat_list_copy, lists);
  239.     EUCALLSET_2(set, Fn_cons,ARG_1(stackbase),set);
  240.  
  241.     res = nil; ptr = nil;
  242.       
  243.     while (TRUE) 
  244.       {
  245.  
  246.     /* Construct args to apply... */
  247.       
  248.     STACK_TMP(set);    
  249.     STACK_TMP(ptr);
  250.     if ((args = mapcar_apply_args(stacktop,set)) == nil) 
  251.       {    
  252.         res=ARG_3(stackbase);
  253.         return(res);
  254.       }
  255.     UNSTACK_TMP(ptr);
  256.     STACK_TMP(ptr);
  257.     EUCALLSET_2(val,module_mv_apply_1,ARG_0(stackbase),args);
  258.     UNSTACK_TMP(ptr);
  259.       
  260.     if (ptr == nil)
  261.       {
  262.         EUCALLSET_2(res, Fn_cons,val,nil);
  263.         ARG_3(stackbase)=res;
  264.         ptr = res;
  265.       }
  266.     else 
  267.       {
  268.         LispObject xx;
  269.         STACK_TMP(ptr);
  270.         EUCALLSET_2(xx, Fn_cons, val,nil);
  271.         UNSTACK_TMP(ptr);
  272.         CDR(ptr) = xx;
  273.         ptr = CDR(ptr);
  274.       }
  275.     UNSTACK_TMP(set);
  276.     mapcar_advance_lists(set);
  277.       }
  278.   }
  279.  
  280.   return(nil);
  281. }
  282. EUFUN_CLOSE
  283.  
  284. EUFUN_3( Fn_mapc, fn, l1, lists)
  285. {
  286.  
  287.   if (!is_cons(l1) && l1 != nil)
  288.     CallError(stacktop,"mapc: not a list",l1,NONCONTINUABLE);
  289.  
  290.   if (FALSE) {
  291.     ;
  292.   }
  293.   else {
  294.     LispObject set,args;
  295.     
  296.     /* More general... */
  297.  
  298.     EUCALLSET_1(set,flat_list_copy,lists);
  299.     EUCALLSET_2(set, Fn_cons,ARG_1(stackbase),set);
  300.  
  301.     while (TRUE) {
  302.       LispObject dummy;
  303.  
  304.       /* Construct args to apply... */
  305.  
  306.       STACK_TMP(set);
  307.       if ((args = mapcar_apply_args(stacktop,set)) == nil) {
  308.     return(nil);
  309.       }
  310.       UNSTACK_TMP(set);
  311.  
  312.       STACK_TMP(set);
  313.       EUCALL_2(module_mv_apply_1,ARG_0(stackbase),args);
  314.       UNSTACK_TMP(set);
  315.       mapcar_advance_lists(set);
  316.     }
  317.   }
  318.  
  319.   return(nil);
  320. }
  321. EUFUN_CLOSE
  322.  
  323. EUFUN_1( flat_list_copy, list)
  324. {
  325.   LispObject xx;
  326.   if (!is_cons(list)) return(nil);
  327.   EUCALLSET_1(xx, flat_list_copy, CDR(list));
  328.   return(EUCALL_2(Fn_cons, CAR(ARG_0(stackbase)),xx));
  329. }
  330. EUFUN_CLOSE
  331.   
  332. /*
  333.  
  334.  * Initialise the module...
  335.  
  336.  */
  337.  
  338. #define LISTOPS_ENTRIES 11
  339. MODULE Module_listops;
  340. LispObject Module_listops_values[LISTOPS_ENTRIES];
  341.  
  342. void initialise_listops(LispObject *stacktop)
  343. {
  344.   open_module(stacktop,
  345.           &Module_listops,
  346.           Module_listops_values,
  347.           "list-operators",
  348.           LISTOPS_ENTRIES);
  349.  
  350.   (void) make_module_function(stacktop,"memq",Fn_memq,2);
  351.   (void) make_module_function(stacktop,"append",Fn_append,2);
  352.   (void) make_module_function(stacktop,"copy-list",flat_list_copy,1);
  353.   (void) make_module_function(stacktop,"null",Fn_null,1);
  354.   (void) make_module_function(stacktop,"nconc",Fn_nconc,2);
  355.   (void) make_module_function(stacktop,"last-pair",Fn_lastpair,1);
  356.   (void) make_module_function(stacktop,"nreverse",Fn_nreverse,1);
  357.   (void) make_module_function(stacktop,"assoc",Fn_assoc,3);
  358.   (void) make_module_function(stacktop,"member",Fn_member,3);
  359.   (void) make_module_function(stacktop,"mapcar",Fn_mapcar,-3);
  360.   (void) make_module_function(stacktop,"mapc",Fn_mapc,-3);
  361.  
  362.   close_module();
  363. }
  364.